COMMENT ⊗   VALID 00002 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002	(declare (fasload struct fas dsk (mac lsp)))
C00011 ENDMK
C⊗;
(declare (fasload struct fas dsk (mac lsp)))

(defstruct local-superclass-info
 (lattice ())
 (root ())
 (alphabetical-paths ())
 (total-order ()))

(declare (special *lattice*))
(declare (special *local-info*))

(defun init () 
       (setq *lattice* ())
       (setq *local-info* (make-local-superclass-info)))

(defmacro defclass (node superclasses ignore)
	  (push `(,node ,superclasses) *lattice*)
	  `(quote ,node))

(defun compute-alphabetical-paths (node local-info)
 (setf (alphabetical-paths local-info)
  (compute-alpha-paths node *lattice*)))

(defun compute-alpha-paths (node lattice)
 (let ((direct-superclasses (cadr (assq node lattice))))
      (cond
       ((null direct-superclasses)
	`((,node ())))
       (t
	(do ((ds direct-superclasses (cdr ds))
	     (paths-above ()))
	    ((null ds)
	     (mapcar #'(lambda (x) `(,node ,@x)) paths-above))
	    (setq paths-above
		  (append
		   paths-above
		   (compute-alpha-paths (car ds) lattice)))))))))

(defun compute-total-order (node)
 (setf (root *local-info*) node)
 (setf (total-order *local-info*) ())
 (compute-alphabetical-paths node *local-info*)
 (setf (lattice *local-info*)
       (let ((all-path-nodes 
	      (apply #'append (alphabetical-paths *local-info*))))
	    (mapcan #'(lambda (x)
			      (cond ((memq (car x) all-path-nodes) (ncons x))
				    (t nil)))
		    *lattice*)))
 (*catch 'inconsistent-lattice
	 (setf (total-order *local-info*)
	       (sort (all-nodes (lattice *local-info*)) #'cpl-less))))

(defun all-nodes (lattice)
 (mapcar #'car lattice))

(defmacro inconsistent ()
 `(progn 
   (error '|Inconsistent Lattice|)
   (*throw 'inconsistent-lattice nil)))

(defmacro when (x y)
	  `(cond (,x ,y)))

;;; cpl-less-1 can return one of:
;;; less
;;; less-equal
;;; equal
;;; greater-equal
;;; greater
;;; unknown

(defun cpl-less (node1 node2)
       (eq (compare node1 node2) 'less))

(defun compare (node1 node2)
 (cond ((eq node1 node2) 'equal)
       ((in-lattice-order node1 node2)
	(when (in-local-precedence-order node2 node1) (inconsistent))
	'less)
       ((in-lattice-order node2 node1)
	(when (in-local-precedence-order node1 node2) (inconsistent))
	'greater)
       ((in-local-precedence-order node1 node2) 'less)
       ((in-local-precedence-order node2 node1) 'greater)
       (t (in-kleene-brouwer-order node1 node2))))

(defun in-lattice-order (node1 node2)
 (let ((paths (alphabetical-paths *local-info*)))
  (do ((paths paths (cdr paths)))
      ((null paths) nil)
   (let ((subpath (memq node1 (car paths))))
    (cond ((memq node2 subpath) (return t)))))))

(defun in-local-precedence-order (node1 node2)
 (do ((lpo (lattice *local-info*) (cdr lpo)))
     ((null lpo) nil)
     (let ((greater (memq node1 (cadr (car lpo)))))
      (cond ((memq node2 greater) (return t))))))

;(defun in-kleene-brouwer-order (node1 node2)
; (let ((path1 (first-alphabetical-path-including node1))
;       (path2 (first-alphabetical-path-including node2)))
;  (do ((path1 path1 (cdr path1))
;       (path2 path2 (cdr path2)))
;      ((not (eq (car path1) (car path2)))
;       (cpl-less (car path1)(car path2))))))

(defun in-kleene-brouwer-order (node1 node2)
  (do ((path1 (alphabetical-paths *local-info*) (cdr path1))
       (less nil)
       (greater nil)
       (less-equal nil)
       (greater-equal nil)
       (unknown nil)
       (equal nil))
      ((null path1)
       (combine less less-equal equal greater-equal greater unknown))
      (cond ((memq node1 (car path1))
	     (do ((path2 (alphabetical-paths *local-info*) (cdr path2)))
		 ((null path2) nil)
		 (cond ((memq node2 (car path2))
			(do ((pth1 (car path1) (cdr pth1))
			     (pth2 (car path2) (cdr pth2)))
			    ((not (eq (compare (car pth1) (car pth2))
				      'equal))
;(print `(paths ,(car path1) ,(car path2)))
			     (caseq (compare (car pth1)(car pth2))
				    (less (setq less t))
				    (less-equal (setq less-equal t))
				    (greater (setq greater t))
				    (greater-equal (setq greater-equal t))
				    (equal (setq equal t))
				    (unknown (setq unknown t)))
			     (caseq (compare (car pth2)(car pth1))
				    (less (setq greater t))
				    (less-equal (setq greater-equal t))
				    (greater (setq less t))
				    (greater-equal (setq less-equal t))
				    (equal (setq equal t))
				    (unknown (setq unknown t))))))))))))

(defmacro none-of l
 `(not (or ,@l)))

(defun combine (less less-equal equal greater-equal greater unknown)
 (cond ((and less (none-of greater less-equal greater-equal equal))
	'less)
       ((and greater (none-of less less-equal greater-equal equal))
	'greater)
       ((and less-equal (none-of greater greater-equal))
	'less-equal)
       ((and greater-equal (none-of less less-equal))
	'greater-equal)
       ((and less equal (none-of greater greater-equal))
	'less-equal)
       ((and greater equal (none-of less less-equal))
	'greater-equal)
       ((and greater-equal less-equal (none-of less greater))
	'equal)
       ((and equal (none-of less greater))
	'equal)
       ((and unknown (none-of less less-equal greater greater-equal equal))
	'unknown)
       (t 'unknown)))

(defun first-alphabetical-path-including (node)
 (do ((paths (alphabetical-paths *local-info*) (cdr paths)))
     ((null paths) nil)
     (cond ((memq node (car paths)) (return (car paths))))))